C Subroutines from program CVALL (Tom Peters, NMR Spectroscopy Group)
C Version: ...ruu/bin/cvall_doc/cvall.f (Aug 30  1991)
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROGRAM CVALL
C
C  Reads different kinds of data-files of molecular structures,
C  and writes them in another format of choice.
C
C  Tom Peters  RUU  Organic Chemistry
C  910715 rewritten renaming code; O-term fix implemented
C  910714 CHARmm included
C  910606 bug repairs; started code for renaming protons
C  901121 connectivity selection for PDB changed
C  901119 Ton Rullman minor improvements and a bug fix
C  901115 various user demands satisfied
C  1990   modified for Iris fc :
C         common blocks completed
C         LSHIFT -> LSHFT, RSHIFT -> RSHFT since Iris has bit-manipulation
C                                          functions with the same name
C  900308 Discover and DNA added
C  900301 sorting improved
C  891115
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C

      SUBROUTINE INIT_CV(iunit,filnam,header,maxh,count)
      integer iunit,maxh,count
      character*80 filnam,header(*)
C--------NOTE:
C     The character variables filnam and header should have the same size
C     as defined by the constants size_FILNAM and size_LINE in AquaMacros.h.
C     The definition of header occurs in several routines in this file.
 
      INCLUDE 'cv_subs.inc'
C
C..... maximum number of atoms
      MAX=count
C..... maximum number of header lines
      MXHEAD=maxh

C..... Set up defaults in common blocks
      DIM=3
      NATO=0
      NATO2=0
      NRES=0
C--------JACR: insert
      NMOL=0
      NHEAD=0
C--------JACR: inserted
      IOR=0
      IOA=0

      BCON=.FALSE.
      CONALL=.FALSE.
      PRO=.FALSE.
      DNA=.FALSE.
      KEEPH=.FALSE.
      KEEPQ=.FALSE.
      KEEPHW=.FALSE.

      FACIN=1.0
      FACOUT=1.0
      RvdW=0.19

C..... Open file
      open(iunit,file=filnam,status='old',readonly)

C..... Initialize header
      do 10 i=1,maxh
   10 header(i)=' '

      RETURN 
      END
      SUBROUTINE CLOSE_CV(iunit)
C
      close(iunit)
      return
      end
C
C..............................................................................
C
C------------------------------------------------------------------------------
C
      INTEGER FUNCTION RDGRO(IUNIT,HEADER,X,Y,Z,
     +                       RESNO,RESNAM,ATONO,ATONAM,CHAIN)
***** TP 901115 modified to read from a longer file
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*)
C
      INTEGER I,IT,N,NR,DNR
      CHARACTER CHN,A1*1
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
      N=0
      READ(UNIT=IUNIT,FMT=1010,END=999)HEADER(1)
      NHEAD=1
      READ(UNIT=IUNIT,FMT=1020)N
      BCON=.FALSE.
      I=0
      NRES=0
      NR=-1
      CHN='0'
      NMOL=0
C***** TP patched 901115
CC   10 CONTINUE
CC        I=I+1
CC        IF (I.GT.MAX) THEN
CC          RDGRO=-1
        IF (N.GT.MAX) THEN
          RDGRO=-N
          RETURN
        ENDIF
      DO 10 IT=1,N
C.....  cannot trust loop counter
        I=I+1
        READ(UNIT=IUNIT,FMT=1030,END=20)RESNO(I),RESNAM(I),
     +  ATONAM(I),ATONO(I),X(I),Y(I),Z(I)
C.....    Count number of different chains and residues
        DNR=ABS(RESNO(I)-NR)
        IF (DNR.NE.0) THEN
          IF (DNR.GT.1) THEN
C.....      if residue numbering is discontinuous,
C           there are certainly more chains
            NMOL=NMOL+1
            CHN=CHAR(ICHAR(CHN)+1)
          ENDIF
          NR=RESNO(I)
          NRES=NRES+1
        ENDIF
        CHAIN(I)(1:1)=CHN
        CHAIN(I)(2:5)='    '
C
C***** Superseded by implementation of atom renaming, TP 910607
*C.....    Get rid of GROMOS/PROEXH peculiar H atom names
*        A1=ATONAM(I)(1:1)
*        CALL UPCASE(A1)
*        IF ( (A1.EQ.'H').AND.(ATONAM(I)(2:2).EQ.' ') ) THEN        
*          ATONAM(I)(2:2)=ATONAM(I)(1:1)
*          ATONAM(I)(1:1)=' '
*        ENDIF
*
C.....    Default use names shifted to the left
        CALL LSHFT(ATONAM(I),5)
        CALL LSHFT(RESNAM(I),5)
C.....    Coordinates to nm (in this case FACIN should be 1.0 !)
        X(I)=X(I)*FACIN
        Y(I)=Y(I)*FACIN
        Z(I)=Z(I)*FACIN
CC      GOTO 10
   10 CONTINUE
   20 CONTINUE
CC      IF (I.NE.N+1) THEN
      IF (I.NE.N) THEN
        RDGRO=-1
        NATO=I-1
        RETURN
      ELSE
        RDGRO=I
        NATO=N
        RETURN
      ENDIF
  999 CONTINUE
      RDGRO=0
      NATO=0
      RETURN
 1010 FORMAT(A80)
 1020 FORMAT(I5,A75)
 1030 FORMAT(I5,A5,A5,I5,3F8.3)
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE WRGRO(IUNIT,INDX,HEADER,X,Y,Z,
     +                 RESNO,RESNAM,ATONO,ATONAM)
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER INDX(*),ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*)
C
      INTEGER I,J
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
      WRITE(UNIT=IUNIT,FMT=1010)HEADER(1)
      WRITE(UNIT=IUNIT,FMT=1020)NATO2
      DO 10 I=1,NATO2
        J=INDX(I)
*already done :        CALL LSHFT(RESNAM(J),5)
        CALL RSHFT(ATONAM(J),5)
        WRITE(UNIT=IUNIT,FMT=1030)RESNO(J)+IOR,RESNAM(J),
     +  ATONAM(J),ATONO(J)+IOA,
     +  X(J)*FACOUT,Y(J)*FACOUT,Z(J)*FACOUT
   10 CONTINUE
 1010 FORMAT(A80)
 1020 FORMAT(I5,A75)
 1030 FORMAT(I5,A5,A5,I5,3F8.3)
      END
C
C------------------------------------------------------------------------------
C
      INTEGER FUNCTION RDDG(IUNIT,HEADER,X,Y,Z,
     +                      RESNO,RESNAM,ATONO,ATONAM,CHAIN,CONN)
***** TP 901115 modified to read from a longer file
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*)
      INTEGER CONN(4,*)
C
      INTEGER I,IT,N,NR,DNR
      CHARACTER CHN
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
      BCON=.TRUE.
      N=0
      DIM=0
      READ(UNIT=IUNIT,FMT=1010,END=999)HEADER(1)
      READ(UNIT=IUNIT,FMT=1020)N,DIM,HEADER(2)
      NHEAD=2
      I=0
      NRES=0
      NR=-1
      CHN='0'
      NMOL=0
C***** TP patched 901115
CC   10 CONTINUE
CC        I=I+1
CC        IF (I.GT.MAX) THEN
CC          RDDG=-1
        IF (N.GT.MAX) THEN
          RDDG=-N
          RETURN
        ENDIF
C***** TP patch 910606
      IF ((DIM.NE.3).AND.(DIM.NE.4)) THEN
        WRITE(*,'(A)')' Assumed dimension 3'
        DIM=3
      ENDIF
      DO 10 IT=1,N
C.....  cannot trust loop counter
        I=I+1
        IF (DIM.EQ.3) THEN
        READ(UNIT=IUNIT,FMT=1030,END=20,ERR=20)RESNO(I),RESNAM(I),
     +  ATONAM(I),ATONO(I),X(I),Y(I),Z(I),
     +  CONN(1,I),CONN(2,I),CONN(3,I),CONN(4,I)
        ELSE IF (DIM.EQ.4) THEN
        READ(UNIT=IUNIT,FMT=1040,END=20,ERR=20)RESNO(I),RESNAM(I),
     +  ATONAM(I),ATONO(I),X(I),Y(I),Z(I),dum,
     +  CONN(1,I),CONN(2,I),CONN(3,I),CONN(4,I)
        ENDIF
C.....    Count number of different chains and residues
        DNR=ABS(RESNO(I)-NR)
        IF (DNR.NE.0) THEN
          IF (DNR.GT.1) THEN
C.....      if residue numbering is discontinuous,
C           there are certainly more chains
            NMOL=NMOL+1
            CHN=CHAR(ICHAR(CHN)+1)
          ENDIF
          NR=RESNO(I)
          NRES=NRES+1
        ENDIF
        CHAIN(I)(1:1)=CHN
        CHAIN(I)(2:5)='    '
C.....    Default use names shifted to the left
        CALL LSHFT(RESNAM(I),5)
        CALL LSHFT(ATONAM(I),5)
C.....    Coordinates are supposed to be in A, convert to nm
        X(I)=X(I)*FACIN
        Y(I)=Y(I)*FACIN
        Z(I)=Z(I)*FACIN
      GOTO 10
C..... Dimension reduced to normal
   10 CONTINUE
   20 CONTINUE
      DIM=3
CC      IF (I.NE.N+1) THEN
      IF (I.NE.N) THEN
        RDDG=-1
        NATO=I-1
        RETURN
      ELSE
        RDDG=I
        NATO=N
        RETURN
      ENDIF
  999 CONTINUE
      RDDG=0
      NATO=0
      RETURN
 1010 FORMAT(A80)
 1020 FORMAT(I5,I5,A70)
 1030 FORMAT(I5,A5,A5,I5,3F8.3,4I5)
 1040 FORMAT(I5,A5,A5,I5,4F8.3,4I5)
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE WRDG(IUNIT,INDX,HEADER,X,Y,Z,
     +                 RESNO,RESNAM,ATONO,ATONAM,CONN)
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER INDX(*),ATONO(*),RESNO(*),CONN(4,*)
      CHARACTER*5 ATONAM(*),RESNAM(*)
C
      INTEGER I,J,N,K
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
      WRITE(UNIT=IUNIT,FMT=1010)HEADER(1)
      WRITE(UNIT=IUNIT,FMT=1020)NATO2,DIM,HEADER(2)
      DO 10 I=1,NATO2
        J=INDX(I)
*already done :        CALL LSHFT(RESNAM(J),5)
        CALL RSHFT(ATONAM(J),5)
        DO 31 K=1,4
C         Keep non-connections to 0 !
          IF (CONN(K,I).EQ.0) CONN(K,I)=-IOA
   31   CONTINUE
        WRITE(UNIT=IUNIT,FMT=1030)RESNO(J)+IOR,RESNAM(J),
     +  ATONAM(J),ATONO(J)+IOA,
     +  X(J)*FACOUT,Y(J)*FACOUT,Z(J)*FACOUT,
     +  CONN(1,I)+IOA,CONN(2,I)+IOA,CONN(3,I)+IOA,CONN(4,I)+IOA
   10 CONTINUE
 1010 FORMAT(A80)
 1020 FORMAT(I5,I5,A70)
 1030 FORMAT(I5,A5,A5,I5,3F8.3,4I5)
      END
C
C------------------------------------------------------------------------------
C
      INTEGER FUNCTION RDPDB(IUNIT,HEADER,X,Y,Z,
     +                       RESNO,RESNAM,ATONO,ATONAM,CHAIN)
C--------JACR: CON removed
CC   +                       RESNO,RESNAM,ATONO,ATONAM,CHAIN,CON)
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*)
C--------JACR: CON removed
CC    INTEGER CON(4,*)
C
      INTEGER I,II,J,N,NR
      CHARACTER*80 INP
      CHARACTER*6 RECTYP
      CHARACTER*5 CHN
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
C..... NB - Many record types are ignored.
C         - Officially, the residue name is 3 characters long, but
C         here the unused 21th character is also taken into account
C         since many other formats allow longer names.
C         - The atom names are supposed to be split in 2 parts :
C         the first 2 characters (right shifted) are the chemical symbol,
C         the second 2 (left shifted) a further identification.
C         Unfortunately, this sometimes makes the atom names incompatible
C         with those from other (ambivalent) formats.
C
      I=0
      NATO=0
      NRES=0
      NR=0
      NHEAD=1
      NMOL=0
      CHN='1    '
      BCON=.FALSE.
   10 CONTINUE
        READ(UNIT=IUNIT,FMT=1010,END=20)INP
        RECTYP=INP(1:6)
        IF (RECTYP.EQ.'HEADER') THEN
          HEADER(1)(1:80)=INP(1:80)
        ELSE IF ( (RECTYP.EQ.'COMPND').OR.(RECTYP.EQ.'REMARK').OR.
     +            (RECTYP.EQ.'FORMUL').OR.(RECTYP.EQ.'CRYST1') ) THEN
          IF (NHEAD.LT.mxhead) THEN
            NHEAD=NHEAD+1
            HEADER(NHEAD)(1:80)=INP(1:80)
          ENDIF
        ELSE IF (RECTYP.EQ.'TER   ') THEN
          NMOL=NMOL+1
C.....    NB Number of chain identifiers limited to 8 !
C            CHAIN field in ATOM records will be ignored.
          CHN(1:1)=CHAR(48+NMOL+1)
        ELSE IF ((RECTYP.EQ.'ATOM  ').OR.(RECTYP.EQ.'HETATM')) THEN
          I=I+1
          IF (I.GT.MAX) THEN
CC            RDPDB=-1
            RDPDB=-I
            RETURN
          ENDIF
          READ(INP,FMT=1020)ATONO(I),ATONAM(I),RESNAM(I),CHAIN(I),
     +    RESNO(I),X(I),Y(I),Z(I)
C.....      Count the number of chains
*           REMOVED : chain must be terminated by TER record
*           Instead, fill in a number for CHAIN() ID
*          IF (CHN.NE.CHAIN(I)) THEN
*            CHN=CHAIN(I)
*            NMOL=NMOL+1
*          ENDIF
           CHAIN(I)=CHN
C.....      Count number of different residues
          IF (NR.NE.RESNO(I)) THEN
            NR=RESNO(I)
            NRES=NRES+1
          ENDIF
C.....      Default use names shifted to the left
          CALL LSHFT(RESNAM(I),4)
          RESNAM(I)(5:5)=' '
          CALL LSHFT(ATONAM(I),4)
          ATONAM(I)(5:5)=' '
          CHAIN(I)(2:5)='    '
C.....      Coordinates are supposed to be in A, convert to nm
          X(I)=X(I)*FACIN
          Y(I)=Y(I)*FACIN
          Z(I)=Z(I)*FACIN
        ELSE IF (RECTYP.EQ.'CONECT') THEN
          BCON=.TRUE.
          READ(INP,FMT=1030)I0,I1,I2,I3,I4
C.....     Find the index of the damned atom
          II=0
          DO 30 J=1,I
            IF (I0.EQ.ATONO(J)) THEN
              II=J
              GOTO 31
            ENDIF
   30     CONTINUE
   31     CONTINUE
C--------JACR: CON removed
CC        CON(1,II)=I1
CC        CON(2,II)=I2
CC        CON(3,II)=I3
CC        CON(4,II)=I4
        ENDIF
      GOTO 10
   20 CONTINUE
      NATO=I
      RDPDB=I
      RETURN
 1010 FORMAT(A80)
 1020 FORMAT(6X,I5,1X,A4,1X,A4,A1,I4,1X,3X,3F8.3,6X,6X,1X,3X)
 1030 FORMAT(6X,I5,4I5,5X,5X,5X,5X,5X,5X)
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE WRPDB(IUNIT,INDX,HEADER,X,Y,Z,
     +                 RESNO,RESNAM,ATONO,ATONAM,CHAIN,CONN)
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER INDX(*),ATONO(*),RESNO(*),CONN(4,*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*),CHN
C
      INTEGER I,J,N,II,JJ,K,NCON0
C***** TP added 901121
      CHARACTER*80 REMARK
      CHARACTER*6 RECTYP

C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
C..... NB - Many record types are not supported.
C         - Especially, HETATM (and HET) are not specified here
C         (replaced by ATOM records). Beware !
C         - Officially, the residue name is 3 characters long, but
C         here the unused 21th character is also taken into account
C         since many other formats allow longer names.
C         - PDB atom names consist of a right-shifted part with the
C         2-letter chemical symbol, and a left-shifted 2-letter further
C         identification. Other formats are more free, and ambivalent.
C         Here, all atoms (except xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx)
C         are preceded by a space, which means that any two-letter elements
C         are misidentified. Too bad. Again, use your editor to take care
C         of names.
C
      DO 10 I=1,NHEAD
        RECTYP=HEADER(I)(1:6)
        IF ( (RECTYP.NE.'COMPND').AND.(RECTYP.NE.'REMARK').AND.
     +       (RECTYP.NE.'FORMUL').AND.(RECTYP.NE.'CRYST1').AND.
     +       (RECTYP.NE.'HEADER') ) THEN
          REMARK='REMARK'//HEADER(I)(1:74)
        ELSE
          REMARK=HEADER(I)
        ENDIF
        WRITE(UNIT=IUNIT,FMT=1010)REMARK
   10 CONTINUE
      CHN(1:5)=CHAIN(INDX(1))(1:5)
      DO 20 I=1,NATO2
        J=INDX(I)
*already done :
*        CALL LSHFT(RESNAM(J),5)
*        CALL LSHFT(CHAIN(J),5)
C.....    Write a 'TER' record at the end of each chain.
C         NB it is not possible (because of the connectivity list)
C            to insert a sequential number for the TER record here.
C            I do not think this poses a problem.
        IF (CHN(1:5).NE.CHAIN(J)(1:5)) THEN
          II=I-1
          JJ=INDX(II)
          WRITE(UNIT=IUNIT,FMT=1030)ATONO(JJ)+IOA,
     +                              RESNAM(JJ),' ',RESNO(JJ)
          CHN(1:5)=CHAIN(J)(1:5)
        ENDIF
C..... Erase chain ID here because INSIGHT/DISCOVER chokes in it
       CHAIN(J)='     '
C..... Start all atom names with a space (except if already 4 pos. long)
***      IF (.NOT.( ( (ATONAM(J)(1:1).EQ.'H').AND.(ATONAM(J)(2:2).NE.' ') )
***    +             .OR.(ATONAM(J)(1:1).EQ.'Q') )) THEN
        IF (ATONAM(J)(4:4).EQ.' ') THEN
          CALL SHIFTR(ATONAM(J),5,1)
        ENDIF
        WRITE(UNIT=IUNIT,FMT=1020)ATONO(J)+IOA,ATONAM(J)(1:4),
     +  RESNAM(J)(1:4),CHAIN(J),RESNO(J)+IOR,
     +  X(J)*FACOUT,Y(J)*FACOUT,Z(J)*FACOUT,1.0,0.0
   20 CONTINUE
C*      WRITE(UNIT=IUNIT,FMT=1030)ATONO(INDX(NATO2))+IOA+1,
C*     +                          RESNAM(INDX(NATO2)),RESNO(INDX(NATO2))
C***** TP modified 901121
      WRITE(UNIT=IUNIT,FMT=1030)ATONO(J)+IOA+1,RESNAM(J)(1:4),
     +                          CHAIN(J),RESNO(J)+IOR
      IF (BCON) THEN
*
      DO 30 I=1,NATO2
        J=INDX(I)
* 901121
        NCON0=0
*
        DO 31 K=1,4
C         Keep non-connections to 0 !
          IF (CONN(K,I).EQ.0) THEN
            CONN(K,I)=-IOA
* 901121
            NCON0=NCON0+1
*
          ENDIF
   31   CONTINUE
* 901121
C         write only if there are any connections
        IF (NCON0.NE.4) THEN
*
        WRITE(UNIT=IUNIT,FMT=1040)ATONO(J)+IOA,
     +  CONN(1,I)+IOA,CONN(2,I)+IOA,CONN(3,I)+IOA,CONN(4,I)+IOA
* 901121
        ENDIF
*
   30 CONTINUE
* 901121
      ENDIF
* ......... BCON
C
      WRITE(UNIT=IUNIT,FMT=1050)
 1010 FORMAT(A80)
 1020 FORMAT('ATOM  ',I5,1X,A4,1X,A4,A1,I4,1X,3X,3F8.3,2F6.2,1X,3X)
 1030 FORMAT('TER   ',I5,6X,A4,A1,I4,1X)
 1040 FORMAT('CONECT',I5,4I5,5X,5X,5X,5X,5X,5X)
 1050 FORMAT('END   ')
      END
C
C------------------------------------------------------------------------------
C
      INTEGER FUNCTION RDDI(IUNIT,HEADER,X,Y,Z,
     +                      RESNO,RESNAM,ATONO,ATONAM,CHAIN)
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*)
C 
      INTEGER I,N,NR
      CHARACTER*5 CHN
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
      BCON=.FALSE.
      READ(UNIT=IUNIT,FMT=1010)HEADER(1)
      READ(UNIT=IUNIT,FMT=1010)HEADER(2)
      READ(UNIT=IUNIT,FMT=1010)HEADER(3)
      NHEAD=3
      I=0
      NRES=0
      NR=0
      CHN='@@@@@'
      NMOL=0
   10 CONTINUE
        I=I+1
        IF (I.GT.MAX) THEN
CC          RDDI=-1
          RDDI=-I
          RETURN
        ENDIF
        READ(UNIT=IUNIT,FMT=1030,END=20)X(I),Y(I),Z(I),RESNO(I),
     +       ATONO(I),RESNAM(I),CHAIN(I),ATONAM(I)
        CALL LSHFT(CHAIN(I),4)
        CHAIN(I)(5:5)=' '
C.....    Count the number of chains
        IF (CHN(1:5).NE.CHAIN(I)(1:5)) THEN
          NMOL=NMOL+1
          CHN(1:5)=CHAIN(I)(1:5)
        ENDIF
C.....    Count number of different residues
        IF (NR.NE.RESNO(I)) THEN
          NR=RESNO(I)
          NRES=NRES+1
        ENDIF
C.....    Default use names shifted to the left
        CALL LSHFT(ATONAM(I),4)
        ATONAM(I)(5:5)=' '
        CALL LSHFT(RESNAM(I),4)
        RESNAM(I)(5:5)=' '
C
C.....    Coordinates to nm (in this case FACIN=?)
        X(I)=X(I)*FACIN
        Y(I)=Y(I)*FACIN
        Z(I)=Z(I)*FACIN
      GOTO 10
   20 CONTINUE
        NATO=I-1
        RDDI=I-1
        RETURN
 1010 FORMAT(A80)
 1030 FORMAT(3F10.5,10X,5X,I5,I5,10X,2A4,2X,A4)
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE WRDI(IUNIT,INDX,HEADER,X,Y,Z,
     +                RESNO,RESNAM,ATONO,ATONAM,CHAIN)
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER INDX(*),ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*)
C
      INTEGER I,J
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
      WRITE(UNIT=IUNIT,FMT=1010)HEADER(1)
      WRITE(UNIT=IUNIT,FMT=1010)HEADER(2)
      WRITE(UNIT=IUNIT,FMT=1010)HEADER(3)
      DO 10 I=1,NATO2
        J=INDX(I)
        CALL RSHFT(RESNAM(J),4)
        CALL RSHFT(ATONAM(J),4)
        WRITE(UNIT=IUNIT,FMT=1030)X(J)*FACOUT,Y(J)*FACOUT,
     +  Z(J)*FACOUT,RESNO(J)+IOR,ATONO(J)+IOA,
     +  RESNAM(J),CHAIN(J),ATONAM(J)
   10 CONTINUE
 1010 FORMAT(A80)
 1030 FORMAT(3F10.5,10X,5X,I5,I5,10X,2A4,2X,A4)
      END
C
C------------------------------------------------------------------------------
C
      INTEGER FUNCTION RDWH(IUNIT,HEADER,X,Y,Z,
     +                      RESNO,RESNAM,ATONO,ATONAM,CHAIN)
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*)
C
      INTEGER I,NR,DNR
      CHARACTER CHN
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
C..... File has no header, make blank
      DO 1 I=1,80
        HEADER(1)(1:1)=' '
    1 CONTINUE
      NHEAD=0
      BCON=.FALSE.
      I=0
      NRES=0
      NR=-1
      CHN='0'
      NMOL=0
C
   10 CONTINUE
        I=I+1
        IF (I.GT.MAX) THEN
CC          RDWH=-1
          RDWH=-I
          RETURN
        ENDIF
        READ(UNIT=IUNIT,FMT=1030,END=20)RESNAM(I),RESNO(I),
     +  ATONAM(I),X(I),Y(I),Z(I)
C.....    Fill in an atom number
        ATONO(I)=I
C.....    Count number of different chains and residues
        DNR=ABS(RESNO(I)-NR)
        IF (DNR.NE.0) THEN
          IF (DNR.GT.1) THEN
C.....      if residue numbering is discontinuous,
C           there are certainly more chains
            NMOL=NMOL+1
            CHN=CHAR(ICHAR(CHN)+1)
          ENDIF
          NR=RESNO(I)
          NRES=NRES+1
        ENDIF
        CHAIN(I)(1:1)=CHN
        CHAIN(I)(2:5)='    '
C.....    Default use names shifted to the left
        CALL LSHFT(RESNAM(I),4)
        RESNAM(I)(5:5)=' '
        CALL LSHFT(ATONAM(I),4)
        ATONAM(I)(5:5)=' '
C.....    Coordinates to nm (in this case FACIN=?)
        X(I)=X(I)*FACIN
        Y(I)=Y(I)*FACIN
        Z(I)=Z(I)*FACIN
      GOTO 10
   20 CONTINUE
        NATO=I-1
        RDWH=I-1
        RETURN
 1030 FORMAT(3X,A4,I4,A4,3F10.5)
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE WRWH(IUNIT,INDX,X,Y,Z,RESNO,RESNAM,ATONAM)
      INTEGER IUNIT
      REAL X(*),Y(*),Z(*)
      INTEGER INDX(*),RESNO(*)
      CHARACTER*5 ATONAM(*)
      CHARACTER*10 RESNAM(*)
C
      INTEGER I,J
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
      DO 10 I=1,NATO2
        J=INDX(I)
*already done        CALL LSHFT(RESNAM(J),5)
        CALL RSHFT(ATONAM(J),4)
        WRITE(UNIT=IUNIT,FMT=1030)RESNAM(J),RESNO(J)+IOR,ATONAM(J),
     +  X(J)*FACOUT,Y(J)*FACOUT,Z(J)*FACOUT
   10 CONTINUE
 1030 FORMAT(3X,A4,I4,A4,3F10.5)
      END
C
C------------------------------------------------------------------------------
C
      INTEGER FUNCTION RDCAR(IUNIT,HEADER,X,Y,Z,
     +                       RESNO,RESNAM,ATONO,ATONAM,CHAIN)
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*),RESNA
C
      INTEGER I,J,N,NR,NEND
      CHARACTER*80 INP
C
      INCLUDE 'cv_subs.inc'
C
      I=0
      NATO=0
      NRES=0
      NR=0
      NMOL=0
      BCON=.FALSE.
      NEND=0
C
C***** Changed for Discover v2.7.0
      READ(UNIT=IUNIT,FMT=1010,END=20)INP
      IF (INP(1:7).EQ.'!BIOSYM') THEN
C.....  V2.7 and higher
        READ(UNIT=IUNIT,FMT=1010,END=20)INP
        IF (INP(1:6).EQ.'PBC=ON') THEN
          READ(UNIT=IUNIT,FMT=1010,END=20)HEADER(1)
          READ(UNIT=IUNIT,FMT=1010,END=20)HEADER(3)
C.....    PBC information :
          READ(UNIT=IUNIT,FMT=1010,END=20)HEADER(2)
          NHEAD=3
        ELSE
          READ(UNIT=IUNIT,FMT=1010,END=20)HEADER(1)
          READ(UNIT=IUNIT,FMT=1010,END=20)HEADER(2)
          NHEAD=2
        ENDIF
      ELSE
C.....  Original format
        HEADER(1)=INP
        READ(UNIT=IUNIT,FMT=1010,END=20)HEADER(2)
        NHEAD=2
      ENDIF
C
   10 CONTINUE
        READ(UNIT=IUNIT,FMT=1010,END=20)INP
        IF ((INP(1:3).EQ.'end').OR.(INP(1:3).EQ.'END')) THEN
          NEND=NEND+1
        ENDIF
        IF (NEND.EQ.2) GOTO 20
        IF (NEND.EQ.1) THEN
          NMOL=NMOL+1
          NEND=0
          GOTO 10
        ENDIF
          I=I+1
          IF (I.GT.MAX) THEN
CC            RDCAR=-1
            RDCAR=-I
            RETURN
          ENDIF
C***** patchwork TP 901114 / disabled JACR
C         Discover has the nasty habit of left-adjusting its resno's.
C         (VAX) Fortran has the weird convention of reading 0's for
C         spaces following numbers in the same fixed format field.
          READ(INP,FMT=1020)ATONAM(I),X(I),Y(I),Z(I),RESNAM(I),
     +      RESNO(I),ATONO(I)
cc          READ(INP,FMT=1020)ATONAM(I),X(I),Y(I),Z(I),RESNAM(I),
cc     +      RESNA,ATONO(I)
cc          READ(RESNA(1:LENGTH(RESNA)),*)RESNO(I)
C.....      Fill in a chain ID
          CHAIN(I)(1:1)=CHAR(NMOL+1)
C.....      Count number of different residues
          IF (NR.NE.RESNO(I)) THEN
            NR=RESNO(I)
            NRES=NRES+1
          ENDIF
C.....      Default use names shifted to the left
          CALL LSHFT(RESNAM(I),4)
          RESNAM(I)(5:5)=' '
          CALL LSHFT(ATONAM(I),4)
          ATONAM(I)(5:5)=' '
          CHAIN(I)(2:5)='    '
C.....      Coordinates are supposed to be in A, convert to nm
          X(I)=X(I)*FACIN
          Y(I)=Y(I)*FACIN
          Z(I)=Z(I)*FACIN
      GOTO 10
   20 CONTINUE
      NATO=I
      RDCAR=I
      RETURN
 1010 FORMAT(A80)
CC 1020 FORMAT(A4,1X,3F15.9,1X,A4,I5,1X,4X,10X,I5)
 1020 FORMAT(A4,1X,3F15.9,1X,A4,A5,1X,4X,10X,I5)
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE WRCAR(IUNIT,INDX,HEADER,X,Y,Z,
     +                 RESNO,RESNAM,ATONO,ATONAM,CHAIN)
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER INDX(*),ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*),CHN
C
      INTEGER I,J,NR,IOR2
      CHARACTER*80 REMARK
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
*REMARK : Still write old format for downward compatibility (TP 910716)
      DO 10 I=1,2
        WRITE(UNIT=IUNIT,FMT=1010)HEADER(I)
   10 CONTINUE
      CHN(1:5)=CHAIN(INDX(1))(1:5)
      NR=RESNO(INDX(1))
C..... Insight conventionally has the atom numbers going from 1 to NATO2
C..... Similarly, within one chain, residue numbers are sequential from 1 on
      DO 20 I=1,NATO2
        J=INDX(I)
*already done :
*        CALL LSHFT(RESNAM(J),5)
*        CALL LSHFT(CHAIN(J),5)
C.....    Write a 'end' record at the end of each chain.
        IF (CHN(1:5).NE.CHAIN(J)(1:5)) THEN
          WRITE(UNIT=IUNIT,FMT=1030)
          CHN(1:5)=CHAIN(J)(1:5)
        ENDIF
        IF (NR.NE.RESNO(J)) THEN
          IOR2=IOR2+1
          NR=RESNO(J)
        ENDIF
        WRITE(UNIT=IUNIT,FMT=1020)ATONAM(J)(1:4),
     +    X(J)*FACOUT,Y(J)*FACOUT,Z(J)*FACOUT,
     +    RESNAM(J)(1:4),IOR2,'    ',0.0,I+IOA
   20 CONTINUE
      WRITE(UNIT=IUNIT,FMT=1030)
 1010 FORMAT(A80)
 1020 FORMAT(A4,1X,3F15.9,1X,A4,I5,1X,A4,F10.4,I5)
 1030 FORMAT('end ')
      END
C
C------------------------------------------------------------------------------
C
      INTEGER FUNCTION RDCHRM(IUNIT,HEADER,X,Y,Z,
     +                        RESNO,RESNAM,ATONO,ATONAM,CHAIN)
**** TP 910714
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*)
C
      INTEGER I,IT,J,N,NR
      REAL dum
      CHARACTER*80 INP
      CHARACTER*5 CHN
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
C..... NB preliminary format, based on an example file
C
      I=0
      N=0
      NATO=0
      NRES=0
      NR=-1
      NHEAD=0
      NMOL=0
      CHN='     '
      BCON=.FALSE.
   10 CONTINUE
        READ(UNIT=IUNIT,FMT=1010,END=999)INP
        IF (INP(1:1).EQ.'*') THEN
          IF (NHEAD.LT.mxhead) THEN
            NHEAD=NHEAD+1
            HEADER(NHEAD)(1:80)=INP(1:80)
          ENDIF
        ELSE
          GOTO 11
        ENDIF
      GOTO 10
   11 CONTINUE
C
      READ(INP,FMT=1015)N
      IF (N.GT.MAX) THEN
        RDCHRM=-N
        RETURN
      ENDIF
C
      DO 20 IT=1,N
C..... Cannot trust loopcounter
        I=I+1
        READ(UNIT=IUNIT,FMT=1020,END=30)ATONO(I),RESNO(I),RESNAM(I),
     +       ATONAM(I),X(I),Y(I),Z(I),CHAIN(I)
C.....      Count number of different residues and molecules
          IF (NR.NE.RESNO(I)) THEN
            NR=RESNO(I)
            NRES=NRES+1
          ENDIF
          IF (CHN(1:5).NE.CHAIN(I)(1:5)) THEN
            CHN=CHAIN(I)
            NMOL=NMOL+1
          ENDIF
C.....      Default use names shifted to the left
          CALL LSHFT(RESNAM(I),5)
          CALL LSHFT(ATONAM(I),4)
          ATONAM(I)(5:5)=' '
C.....      Coordinates are supposed to be in A, convert to nm
          X(I)=X(I)*FACIN
          Y(I)=Y(I)*FACIN
          Z(I)=Z(I)*FACIN
   20 CONTINUE
   30 CONTINUE
      IF (I.NE.N) THEN
        NATO=I-1
        RDCHRM=-1
        RETURN
      ELSE
        NATO=N
        RDCHRM=I
        RETURN
      ENDIF
  999 CONTINUE
      NATO=0
      RDCHRM=0
      RETURN
 1010 FORMAT(A80)
 1015 FORMAT(I5)
 1020 FORMAT(I5,I5,1X,A5,A4,3F10.5,A5,3X,2X,10X)
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE WRCHRM(IUNIT,INDX,HEADER,X,Y,Z,
     +                  RESNO,RESNAM,ATONO,ATONAM,CHAIN)
**** TP 910714
      INTEGER IUNIT
      CHARACTER*80 HEADER(*)
      REAL X(*),Y(*),Z(*)
      INTEGER INDX(*),ATONO(*),RESNO(*)
      CHARACTER*5 ATONAM(*),RESNAM(*),CHAIN(*),CHN
C
      INTEGER I,J,N,K
      CHARACTER*80 REMARK
C..... many variables are irrelevant, but are in common blocks,
C      and Iris fc complains if common blocks are incomplete
C
      INCLUDE 'cv_subs.inc'
C
C..... NB preliminary format, based on an example file
C
      DO 10 I=1,NHEAD
        REMARK='*'//HEADER(I)(1:79)
        WRITE(UNIT=IUNIT,FMT=1010)REMARK
   10 CONTINUE
C
      WRITE(UNIT=IUNIT,FMT=1015)NATO2
C
      CHN(1:5)=CHAIN(INDX(1))(1:5)
      DO 20 I=1,NATO2
        J=INDX(I)
*already done :
*        CALL LSHFT(RESNAM(J),5)
        CALL RSHFT(CHAIN(J),5)
C..... Erase chain ID here because INSIGHT/DISCOVER chokes in it
C       CHAIN(J)='     '
        WRITE(UNIT=IUNIT,FMT=1020)ATONO(J)+IOA,RESNO(J)+IOR,
     +  RESNAM(J),ATONAM(J)(1:4),
     +  X(J)*FACOUT,Y(J)*FACOUT,Z(J)*FACOUT,
     +  CHAIN(J)(1:5),RESNO(J)+IOR,0.0
   20 CONTINUE
 1010 FORMAT(A80)
 1015 FORMAT(I5)
 1020 FORMAT(I5,I5,1X,A5,A4,3F10.5,A5,I3,2X,F10.5)
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE LSHFT(ATOM,N)
C..... left adjust N characters
      CHARACTER ATOM(*)
      INTEGER N,I,J
      DO 10 I=1,N
      IF(ATOM(1).EQ.' ')THEN
        DO 20 J=1,N-1
          ATOM(J)=ATOM(J+1)
   20   CONTINUE
        ATOM(N)=' '
      ELSE
        RETURN
      ENDIF
   10 CONTINUE
      RETURN
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE RSHFT(ATOM,N)
C..... right adjust N characters
      CHARACTER ATOM(*)
      INTEGER N,I,J
      DO 10 I=1,N
      IF(ATOM(N).EQ.' ')THEN
        DO 20 J=N,2,-1
          ATOM(J)=ATOM(J-1)
   20   CONTINUE
        ATOM(1)=' '
      ELSE
        RETURN
      ENDIF
   10 CONTINUE
      RETURN
      END
C
C------------------------------------------------------------------------------
C
      SUBROUTINE SHIFTR(ATOM,L,N)
C..... shift L characters N positions to the right:
C      the N characters L-N+1 to L are removed, the characters 1 to N
C      become blanks
      CHARACTER ATOM(*)
      INTEGER L,N,I,J
      DO 10 I=1,N
        DO 20 J=L,2,-1
          ATOM(J)=ATOM(J-1)
   20   CONTINUE
        ATOM(1)=' '
   10 CONTINUE
      RETURN
      END
C
C==============================================================================
